home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / ktencode / vbwin30.bas < prev   
BASIC Source File  |  1995-10-23  |  5KB  |  217 lines
  1. 'Programmed by Karl Albrecht (KARL25@AOL.COM)
  2. Function KTEncrypt (ByVal PASSWORD$, ByVal strng$, Flag%, Errors$)
  3.   
  4.   'Dimension the Adjust array
  5.   ReDim Adjust(4)
  6.   
  7.   'Set error capture routine
  8.   On Local Error GoTo ErrorHandler
  9.  
  10.   'Preserve original string
  11.   original$ = strng$
  12.  
  13.   
  14.   
  15.   'Check for errors (Errorcodes are custom)
  16.   'Is there Password??
  17.   If Len(PASSWORD$) = 0 Then Error 31100
  18.   
  19.   'Is there a strng$ to work with?
  20.   If Len(strng$) = 0 Then Error 31110
  21.  
  22.   'Check to see if it is an encoded file
  23.   If Right$(strng$, 5) = String$(5, 255) Then
  24.     'if encoding warn!
  25.     If Flag% = 0 Then Error 31120
  26.   Else
  27.     'If decoding warn
  28.     If Flag% <> 0 Then Error 31130
  29.   End If
  30.   
  31.  
  32.   
  33.   'Create a four part encryption code based on password
  34.   'First Adjust code based on length of password
  35.   Adjust(1) = Len(PASSWORD$)
  36.   
  37.   'If first character ascii code even make adjust negative
  38.   If Asc(Left$(PASSWORD$, 1)) / 2 = Int(Asc(Left$(PASSWORD$, 1)) / 2) Then
  39.     Adjust(1) = Adjust(1) * -1
  40.   End If
  41.  
  42.   'Second Adjust code based on first and last character ascii codes
  43.   Adjust(2) = Asc(Left$(PASSWORD$, 1)) - Asc(Right$(PASSWORD$, 1))
  44.  
  45.   'Third code based on average of all ascii codes
  46.   TotalAscii = 0
  47.   For Looper = 1 To Len(PASSWORD$)
  48.     TotalAscii = TotalAscii + Asc(Mid$(PASSWORD$, Looper, 1))
  49.   Next Looper
  50.   Adjust(3) = Int(TotalAscii / Len(PASSWORD$) / 3)
  51.  
  52.   'Fourth code based on previous three
  53.   Adjust(4) = Adjust(1) + Adjust(2) + Adjust(3)
  54.  
  55.   
  56.   
  57.   'Now check if any Adjust codes are zero
  58.   'If it is zero make it not zero (any number is fine!)
  59.   For Looper = 1 To 4
  60.     If Adjust(Looper) = 0 Then Adjust(Looper) = Looper + Len(PASSWORD$)
  61.   Next Looper
  62.  
  63.   
  64.   'Now check if any adjusts are the same
  65.   NotYet% = 1
  66.   Do While NotYet%
  67.     NotYet% = 0
  68.     For Loop1 = 1 To 4
  69.       For Loop2 = 1 To 4
  70.         'Don't compare same items
  71.         If Loop1 <> Loop2 Then
  72.           
  73.           'Check for a match
  74.           If Adjust(Loop1) = Adjust(Loop2) Then
  75.             Adjust(Loop2) = Adjust(Loop2) + Len(PASSWORD$)
  76.             
  77.             'Make sure we didn't make it zero
  78.             If Adjust(Loop2) = 0 Then Adjust(2) = Adjust(Loop2) + Len(PASSWORD$)
  79.             
  80.             NotYet% = 1
  81.           End If
  82.  
  83.         End If
  84.       Next Loop2
  85.     Next Loop1
  86.   Loop
  87.  
  88.  
  89.   
  90.   
  91.   'Encode or deocde
  92.   Counts = 0: Looper = 0
  93.  
  94.   'Loop until scanned though the whole file
  95.   Do While Looper < Len(strng$)
  96.     
  97.     'Add to Looper
  98.     Looper = Looper + 1
  99.  
  100.     'Keep Adjust code Counts from 1 to 4
  101.     Counts = Counts + 1
  102.     If Counts = 5 Then Counts = 1
  103.     
  104.     'Get the character to change
  105.     ToChange = Asc(Mid$(strng$, Looper, 1))
  106.     
  107.     'ENCODE   Flag%=0
  108.     If Flag% = 0 Then
  109.       
  110.       'If adjustment to high or low then reverse the coding and
  111.       'add in a chr$(255) to mark the change
  112.       If ToChange - Adjust(Counts) < 1 Or ToChange - Adjust(Counts) > 254 Then
  113.         
  114.         Addin$ = Chr$(255) + Chr$(ToChange + Adjust(Counts))
  115.         strng$ = Left$(strng$, Looper - 1) + Addin$ + Mid$(strng$, Looper + 1)
  116.         Looper = Looper + 1
  117.       
  118.       'If adjustment OK then just cahnge the character
  119.       Else
  120.         
  121.         Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  122.  
  123.       End If
  124.  
  125.     'DECODE  Flag% <> 0
  126.     Else
  127.       
  128.       'If find a CHR$(255) then remove it and set Flag255% to
  129.       'ensure reverse codes on next pass reverse coding
  130.       If ToChange = 255 Then
  131.         
  132.         strng$ = Left$(strng$, Looper - 1) + Mid$(strng$, Looper + 1)
  133.         Flag255% = 1
  134.         'Since CHR$(255) was removed we need to back up Looper
  135.         'and Counts because characters all shifted to the left
  136.         Looper = Looper - 1
  137.         Counts = Counts - 1
  138.       
  139.       'If not CHR$(255) then decode watching if Flag255% is set
  140.       Else
  141.         If Flag255% = 1 Then
  142.           Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  143.           Flag255% = 0
  144.         Else
  145.           Mid$(strng$, Looper, 1) = Chr$(ToChange + Adjust(Counts))
  146.         End If
  147.       End If
  148.  
  149.     End If
  150.     
  151.   Loop
  152.  
  153.   
  154.   
  155.   
  156.   'Set function equal to changed string
  157.   If Flag% = 0 Then
  158.     
  159.     'Tack on CHR$(255) to end so it can be recognized as encoded
  160.     KTEncrypt = strng$ + String$(5, 255)
  161.  
  162.   Else
  163.     
  164.     KTEncrypt = strng$
  165.   
  166.   End If
  167.  
  168.   'Make sure Errors$ is cleared
  169.   Errors$ = ""
  170.  
  171.   Exit Function
  172.  
  173.  
  174.  
  175. ErrorHandler:
  176.   Select Case Err
  177.  
  178.     'Illegal Function Call --> out of range ASCII code
  179.     Case 5
  180.       Errors$ = "INVALID PASSWORD!"
  181.  
  182.     'Is there Password??
  183.     Case 31100
  184.       Errors$ = "NO PASSWORD!"
  185.       
  186.     'Is there a strng$ to work with?
  187.     Case 31110
  188.       Errors$ = "NO STRING!"
  189.  
  190.     'Encoding a encoded file?
  191.     Case 31120
  192.       If UCase$(Errors$) = "FORCE" Then
  193.         Resume Next
  194.       Else
  195.         Errors$ = "FILE ALREADY ENCODED!"
  196.       End If
  197.  
  198.     'Decoding a non-encoded file?
  199.     Case 31130
  200.       If UCase$(Errors$) = "FORCE" Then
  201.         Resume Next
  202.       Else
  203.         Errors$ = "FILE NOT ENCODED!"
  204.       End If
  205.     
  206.     'Unanticipated
  207.     Case Else
  208.       Errors$ = Error$(Err)
  209.  
  210.   End Select
  211.   
  212.   KTEncrypt = original$
  213.   Exit Function
  214.  
  215. End Function
  216.  
  217.